Programming Languages Suite/ProgramD2.iso/Visual Database/Visual BASIC 5.0 (Ent. Edition)/Vb5ent Extractor.EXE/VB/SAMPLES/COMPTOOL/ADDINS/TABORDER/TABORDER.DOB

Visual Basic Form | 1996-10-29 | 14.3 KB | 439 lines

VERSION 5.00
Begin VB.UserDocument docTabOrder
   ClientHeight    =   660
   ClientLeft      =   4110
   ClientTop       =   3195
   ClientWidth     =   2085
   HScrollSmallChange=   225
   KeyPreview      =   -1  'True
   LockControls    =   -1  'True
   ScaleHeight     =   660
   ScaleWidth      =   2085
   Tag             =   "10"
   VScrollSmallChange=   225
   Begin VB.CommandButton cmdRefresh
      Height          =   330
      Left            =   1365
      Picture         =   "TabOrder.dox":0000
      Style           =   1  'Graphical
      TabIndex        =   5
      Top             =   15
      UseMaskColor    =   -1  'True
      Width           =   330
   End
   Begin VB.CommandButton cmdLeftToRight
      Height          =   330
      Left            =   1035
      Picture         =   "TabOrder.dox":0102
      Style           =   1  'Graphical
      TabIndex        =   4
      ToolTipText     =   "102"
      Top             =   15
      UseMaskColor    =   -1  'True
      Width           =   330
   End
   Begin VB.CommandButton cmdTopToBottom
      Height          =   330
      Left            =   705
      Picture         =   "TabOrder.dox":0204
      Style           =   1  'Graphical
      TabIndex        =   3
      ToolTipText     =   "102"
      Top             =   15
      UseMaskColor    =   -1  'True
      Width           =   330
   End
   Begin VB.CommandButton cmdDown
      Height          =   330
      Left            =   375
      Picture         =   "TabOrder.dox":0306
      Style           =   1  'Graphical
      TabIndex        =   2
      ToolTipText     =   "104"
      Top             =   15
      UseMaskColor    =   -1  'True
      Width           =   330
   End
   Begin VB.CommandButton cmdUp
      Height          =   330
      Left            =   45
      Picture         =   "TabOrder.dox":0408
      Style           =   1  'Graphical
      TabIndex        =   1
      ToolTipText     =   "102"
      Top             =   15
      UseMaskColor    =   -1  'True
      Width           =   330
   End
   Begin VB.CommandButton cmdApply
      Height          =   330
      Left            =   1695
      Picture         =   "TabOrder.dox":050A
      Style           =   1  'Graphical
      TabIndex        =   6
      Top             =   15
      UseMaskColor    =   -1  'True
      Width           =   330
   End
   Begin VB.ListBox lstTabIndex
      DragIcon        =   "TabOrder.dox":060C
      Height          =   285
      IntegralHeight  =   0   'False
      Left            =   30
      TabIndex        =   0
      Top             =   360
      Width           =   2025
   End
Attribute VB_Name = "docTabOrder"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Dim mcmpCurrentForm As VBComponent      'current form
Dim mcolCtls        As VBControls       'form's controls
'refresh types
Const NEWFORM = 0
Const TOPTOBOTTOM = 1
Const LEFTTORIGHT = 2
Const REFRESHCTLS = 3
'================================================
' this sub sets the new tab order for all
' of the controls on te current form
' based on their order in the listbox
'================================================
Private Sub cmdApply_Click()
  On Error GoTo cmdApply_ClickErr
  Dim i As Integer
  Dim sTmp As String
  Dim nCtlArrIndex As Integer
  If InRunMode(gVBInstance) Then Exit Sub
  Screen.MousePointer = vbHourglass
  For i = 0 To lstTabIndex.ListCount - 1
    GetNameAndIndex lstTabIndex.List(i), sTmp, nCtlArrIndex
    If nCtlArrIndex >= 0 Then
      'set the new tab index
      mcmpCurrentForm.Designer.VBControls.Item(sTmp, nCtlArrIndex).Properties!TabIndex = i
    Else
      'set the new tab index
      mcmpCurrentForm.Designer.VBControls.Item(sTmp).Properties!TabIndex = i
    End If
  Next
  Screen.MousePointer = vbDefault
  Exit Sub
cmdApply_ClickErr:
  If MsgBox(Err.Description & vbCrLf & "Resume?", vbYesNo) = vbYes Then
    Resume Next
  End If
  Screen.MousePointer = vbDefault
End Sub
Private Sub cmdLeftToRight_Click()
  RefreshList LEFTTORIGHT
End Sub
Private Sub cmdTopToBottom_Click()
  RefreshList TOPTOBOTTOM
End Sub
Private Sub cmdRefresh_Click()
  RefreshList REFRESHCTLS
End Sub
Private Sub UserDocument_Show()
  'load the strings from the resource file
  cmdUp.ToolTipText = LoadResString(100)
  cmdDown.ToolTipText = LoadResString(101)
  cmdTopToBottom.ToolTipText = LoadResString(102)
  cmdLeftToRight.ToolTipText = LoadResString(103)
  cmdRefresh.ToolTipText = LoadResString(104)
  cmdApply.ToolTipText = LoadResString(105)
End Sub
Private Sub UserDocument_Resize()
  lstTabIndex.Width = ScaleWidth - (lstTabIndex.Left * 2)
  lstTabIndex.Height = ScaleHeight - (cmdApply.Height + 100)
End Sub
'this sub moves the dragged item to a new location
'based on the Y coordinate where it was dropped
Private Sub lstTabIndex_DragDrop(Source As Control, x As Single, Y As Single)
  Dim sTmp As String
  Dim nListIndex As Integer
  Dim nPos As Integer
  Dim i As Integer
  With lstTabIndex
    nListIndex = .ListIndex
    If Source = lstTabIndex Then
      If nListIndex >= 0 Then
        sTmp = .Text
        nPos = (Y \ TextHeight(sTmp)) + .TopIndex
        'check for the last item
        If nPos > .ListCount Then
          nPos = .ListCount
        End If
        .AddItem sTmp, nPos
        If nListIndex > nPos Then
          .RemoveItem nListIndex + 1
        Else
          .RemoveItem nListIndex
        End If
      End If
    End If
  End With
End Sub
Sub lstTabIndex_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button = vbLeftButton Then lstTabIndex.Drag
End Sub
Private Sub cmdUp_Click()
  On Error Resume Next
  Dim nItem As Integer
  With lstTabIndex
    If .ListIndex < 0 Then Exit Sub
    nItem = .ListIndex
    If nItem = 0 Then Exit Sub  'can't move 1st item up
    'move item up
    .AddItem .Text, nItem - 1
    'remove old item
    .RemoveItem nItem + 1
    'select the item that was just moved
    .Selected(nItem - 1) = True
  End With
End Sub
Private Sub cmdDown_Click()
  On Error Resume Next
  Dim nItem As Integer
  With lstTabIndex
    If .ListIndex < 0 Then Exit Sub
    nItem = .ListIndex
    If nItem = .ListCount - 1 Then Exit Sub 'can't move last item down
    'move item down
    .AddItem .Text, nItem + 2
    'remove old item
    .RemoveItem nItem
    'select the item that was just moved
    .Selected(nItem + 1) = True
  End With
End Sub
'======================================================
'this function returns a value to put in the listbox
'for a control. It appends the Caption property
'if it exists and is not null. It also appends
'the control array index if the control is a
'member of a control array
'======================================================
Function ControlName(ctl As VBIDE.VBControl) As String
  On Error Resume Next
  Dim sTmp As String
  Dim sCaption As String
  Dim i As Integer
  sTmp = ctl.Properties!Name
  sCaption = ctl.Properties!Caption
  'will be null if there isn't one
  i = ctl.Properties!Index
  If i >= 0 Then
    sTmp = sTmp & "(" & i & ")"
  End If
  If Len(sCaption) > 0 Then
    ControlName = sTmp & " - '" & sCaption & "'"
  Else
    ControlName = sTmp
  End If
  Err.Clear
End Function
'======================================================
'this sub rebuilds the list from the form's controls
'======================================================
Public Sub RefreshList(nType As Integer)
  On Error GoTo RefreshListErr
  Dim i As Integer
  Dim ctl As VBControl
  Dim sTmp As String
  Dim ti As Integer
  Dim sCtlName As String
  Dim nCtlArrIndex As Integer
  If InRunMode(gVBInstance) Then Exit Sub
  'clear the list control
  lstTabIndex.Clear
  If gVBInstance.ActiveVBProject Is Nothing Then Exit Sub
  If nType = NEWFORM Then
    If mcmpCurrentForm Is gVBInstance.SelectedVBComponent Then
      'same one as we have now
      Exit Sub
    End If
  End If
  'load the component
  Set mcmpCurrentForm = gVBInstance.SelectedVBComponent
  'check to see if we have a valid component
  If mcmpCurrentForm Is Nothing Then
    Exit Sub
  End If
  'make sure the active component is a form, user control or property page
  If (mcmpCurrentForm.Type <> vbext_ct_VBForm) And _
     (mcmpCurrentForm.Type <> vbext_ct_UserControl) And _
     (mcmpCurrentForm.Type <> vbext_ct_DocObject) And _
     (mcmpCurrentForm.Type <> vbext_ct_PropPage) Then
    Exit Sub
  End If
  Set mcolCtls = mcmpCurrentForm.Designer.VBControls
'  hWindow.Caption = mcmpCurrentForm.Name & " - " & LoadResString(10)
  For Each ctl In mcmpCurrentForm.Designer.VBControls
    'try to get the tabindex
    On Error Resume Next
    ti = ctl.Properties!TabIndex
    If Err Then
      'doesn't have a tabindex
      Err.Clear
      GoTo SkipIt
    End If
    On Error GoTo RefreshListErr
    sTmp = ControlName(ctl)
    'find out where it goes in the list
    Select Case nType
      Case NEWFORM, REFRESHCTLS
        For i = 0 To lstTabIndex.ListCount - 1
          If ti < lstTabIndex.ItemData(i) Then
            Exit For
          End If
        Next

      Case TOPTOBOTTOM
        'rearrange from top to bottom
        For i = lstTabIndex.ListCount To 1 Step -1
          GetNameAndIndex lstTabIndex.List(i - 1), sCtlName, nCtlArrIndex
          If nCtlArrIndex >= 0 Then
            'control array member
            If ctl.Properties!Top > mcolCtls(sCtlName, nCtlArrIndex).Properties!Top Then
              'it is above the current list item
              Exit For
            ElseIf ctl.Properties!Top = mcolCtls(sCtlName, nCtlArrIndex).Properties!Top Then
              'it is at the same top position so see if it is farther left
              If ctl.Properties!Left > mcolCtls(sCtlName, nCtlArrIndex).Properties!Left Then
                Exit For
              End If
            End If
          Else
            If ctl.Properties!Top > mcolCtls(sCtlName).Properties!Top Then
              Exit For
            ElseIf ctl.Properties!Top = mcolCtls(sCtlName).Properties!Top Then
              If ctl.Properties!Left > mcolCtls(sCtlName).Properties!Left Then
                Exit For
              End If
            End If
          End If
        Next

      Case LEFTTORIGHT
        'rearrange from left to right
        For i = lstTabIndex.ListCount To 1 Step -1
          GetNameAndIndex lstTabIndex.List(i - 1), sCtlName, nCtlArrIndex
          If nCtlArrIndex >= 0 Then
            'control array member
            If ctl.Properties!Left > mcolCtls(sCtlName, nCtlArrIndex).Properties!Left Then
              Exit For
            ElseIf ctl.Properties!Left = mcolCtls(sCtlName, nCtlArrIndex).Properties!Left Then
              If ctl.Properties!Top > mcolCtls(sCtlName, nCtlArrIndex).Properties!Top Then
                Exit For
              End If
            End If
          Else
            If ctl.Properties!Left > mcolCtls(sCtlName).Properties!Left Then
              Exit For
            ElseIf ctl.Properties!Left = mcolCtls(sCtlName).Properties!Left Then
              If ctl.Properties!Top > mcolCtls(sCtlName).Properties!Top Then
                Exit For
              End If
            End If
          End If
        Next

    End Select
    'add it to the list
    lstTabIndex.AddItem sTmp, i
    lstTabIndex.ItemData(lstTabIndex.NewIndex) = ti
    lstTabIndex.Refresh
SkipIt:
  Next
  Exit Sub
RefreshListErr:
  MsgBox Err.Description
End Sub
'======================================================
'this sub is called when a control gets removed
'======================================================
Public Sub ControlRemoved(ctl As VBControl)
  Dim sTmp As String
  Dim i As Integer
  sTmp = ControlName(ctl)
  For i = 0 To lstTabIndex.ListCount - 1
    If lstTabIndex.List(i) = sTmp Then
      'remove it from the list
      lstTabIndex.RemoveItem i
      Exit Sub
    End If
  Next
End Sub
'======================================================
'this sub is called when a control gets added
'======================================================
Public Sub ControlAdded(ctl As VBControl)
  Dim i As Integer
  'try to get the tabindex
  On Error Resume Next
  i = ctl.Properties!TabIndex
  If Err Then
    Err.Clear
    'doesn't have a tabindex
    Exit Sub
  End If
  lstTabIndex.AddItem ControlName(ctl)
End Sub
'======================================================
'this sub is called when a control gets renamed
'======================================================
Public Sub ControlRenamed(ctl As VBControl, sOldName As String, lOldIndex As Long)
  On Error Resume Next
  Dim sTmp As String
  Dim i As Integer
  If lOldIndex >= 0 Then
    sOldName = sOldName & "(" & lOldIndex & ")"
  End If
  sTmp = ControlName(ctl)
  For i = 0 To lstTabIndex.ListCount - 1
    If Left$(lstTabIndex.List(i), Len(sOldName)) = sOldName Then
      'remove it from the list
      lstTabIndex.RemoveItem i
      'add it back with the new name
      lstTabIndex.AddItem sTmp, i
      Exit Sub
    End If
  Next
  Err.Clear
End Sub
Private Sub UserDocument_KeyDown(KeyCode As Integer, Shift As Integer)
  'pass the keystrokes onto the IDE
  HandleKeyDown Me, KeyCode, Shift
End Sub
'======================================================
'this sub extracts the control name and index
'from the formatted list item
'======================================================
Sub GetNameAndIndex(sListItem As String, sName As String, nIndex As Integer)
  Dim nPos As Integer
  Dim nPos2 As Integer
  Dim sTmp As String
  'strip off the caption if there is one
  nPos = InStr(sListItem, " ")
  If nPos > 0 Then
    sTmp = Left$(sListItem, nPos - 1)
  Else
    sTmp = sListItem
  End If
  'now check for an index
  nPos = InStr(sTmp, "(")
  If nPos > 0 Then
    'control has an index so we need to
    'strip it off and save it
    nPos2 = InStr(sTmp, ")")
    nIndex = Val(Mid$(sTmp, nPos + 1, nPos2 - nPos))
    sName = Left$(sTmp, nPos - 1)
  Else
    nIndex = -1
    sName = sTmp
  End If
End Sub